home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / mosmllib / Binarymap.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  7.3 KB  |  219 lines  |  [TEXT/R*ch]
  1. (* Binarymap -- modified for Moscow ML 
  2.  * from SML/NJ library v. 0.2 file binary-dict.sml.
  3.  * COPYRIGHT (c) 1993 by AT&T Bell Laboratories.  
  4.  * See file mosml/copyrght/copyrght.att for details.
  5.  *
  6.  * This code was adapted from Stephen Adams' binary tree implementation
  7.  * of applicative integer sets.
  8.  *
  9.  *   Copyright 1992 Stephen Adams.
  10.  *
  11.  *    This software may be used freely provided that:
  12.  *      1. This copyright notice is attached to any copy, derived work,
  13.  *         or work including all or part of this software.
  14.  *      2. Any derived work must contain a prominent notice stating that
  15.  *         it has been altered from the original.
  16.  *
  17.  *
  18.  *   Name(s): Stephen Adams.
  19.  *   Department, Institution: Electronics & Computer Science,
  20.  *      University of Southampton
  21.  *   Address:  Electronics & Computer Science
  22.  *             University of Southampton
  23.  *         Southampton  SO9 5NH
  24.  *         Great Britian
  25.  *   E-mail:   sra@ecs.soton.ac.uk
  26.  *
  27.  *   Comments:
  28.  *
  29.  *     1.  The implementation is based on Binary search trees of Bounded
  30.  *         Balance, similar to Nievergelt & Reingold, SIAM J. Computing
  31.  *         2(1), March 1973.  The main advantage of these trees is that
  32.  *         they keep the size of the tree in the node, giving a constant
  33.  *         time size operation.
  34.  *
  35.  *     2.  The bounded balance criterion is simpler than N&R's alpha.
  36.  *         Simply, one subtree must not have more than `weight' times as
  37.  *         many elements as the opposite subtree.  Rebalancing is
  38.  *         guaranteed to reinstate the criterion for weight>2.23, but
  39.  *         the occasional incorrect behaviour for weight=2 is not
  40.  *         detrimental to performance.
  41.  *
  42.  *)
  43.  
  44. exception NotFound
  45.  
  46. fun wt (i : int) = 3 * i
  47.  
  48. datatype ('key, 'a) dict = 
  49.     DICT of ('key * 'key -> order) * ('key, 'a) tree
  50. and ('key, 'a) tree =
  51.     E 
  52.   | T of {key   : 'key, 
  53.       value : 'a, 
  54.       cnt   : int, 
  55.       left  : ('key, 'a) tree, 
  56.       right : ('key, 'a) tree}
  57.  
  58. fun treeSize E            = 0
  59.   | treeSize (T{cnt,...}) = cnt
  60.  
  61. fun numItems (DICT(_, t)) = treeSize t
  62.  
  63. local
  64.     fun N(k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E}
  65.       | N(k,v,E,r as T n) = T{key=k,value=v,cnt=1+(#cnt n),left=E,right=r}
  66.       | N(k,v,l as T n,E) = T{key=k,value=v,cnt=1+(#cnt n),left=l,right=E}
  67.       | N(k,v,l as T n,r as T n') = 
  68.           T{key=k,value=v,cnt=1+(#cnt n)+(#cnt n'),left=l,right=r}
  69.  
  70.     fun single_L (a,av,x,T{key=b,value=bv,left=y,right=z,...}) = 
  71.           N(b,bv,N(a,av,x,y),z)
  72.       | single_L _ = raise Match
  73.     fun single_R (b,bv,T{key=a,value=av,left=x,right=y,...},z) = 
  74.           N(a,av,x,N(b,bv,y,z))
  75.       | single_R _ = raise Match
  76.     fun double_L (a,av,w,T{key=c,value=cv, 
  77.                left=T{key=b,value=bv,left=x,right=y,...},
  78.                right=z,...}) =
  79.           N(b,bv,N(a,av,w,x),N(c,cv,y,z))
  80.       | double_L _ = raise Match
  81.     fun double_R (c,cv,T{key=a,value=av,left=w,
  82.              right=T{key=b,value=bv,left=x,right=y,...},...},z) = 
  83.           N(b,bv,N(a,av,w,x),N(c,cv,y,z))
  84.       | double_R _ = raise Match
  85.  
  86.     fun T' (k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E}
  87.       | T' (k,v,E,r as T{right=E,left=E,...}) =
  88.           T{key=k,value=v,cnt=2,left=E,right=r}
  89.       | T' (k,v,l as T{right=E,left=E,...},E) =
  90.           T{key=k,value=v,cnt=2,left=l,right=E}
  91.  
  92.       | T' (p as (_,_,E,T{left=T _,right=E,...})) = double_L p
  93.       | T' (p as (_,_,T{left=E,right=T _,...},E)) = double_R p
  94.  
  95.         (* these cases almost never happen with small weight*)
  96.       | T' (p as (_,_,E,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...})) =
  97.           if ln < rn then single_L p else double_L p
  98.       | T' (p as (_,_,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...},E)) =
  99.           if ln > rn then single_R p else double_R p
  100.  
  101.       | T' (p as (_,_,E,T{left=E,...})) = single_L p
  102.       | T' (p as (_,_,T{right=E,...},E)) = single_R p
  103.  
  104.       | T' (p as (k,v,l as T{cnt=ln,left=ll,right=lr,...},
  105.                       r as T{cnt=rn,left=rl,right=rr,...})) =
  106.           if rn >= wt ln then (*right is too big*)
  107.             let val rln = treeSize rl
  108.                 val rrn = treeSize rr
  109.             in
  110.               if rln < rrn then  single_L p  else  double_L p
  111.             end
  112.         
  113.           else if ln >= wt rn then  (*left is too big*)
  114.             let val lln = treeSize ll
  115.                 val lrn = treeSize lr
  116.             in
  117.               if lrn < lln then  single_R p  else  double_R p
  118.             end
  119.     
  120.           else T{key=k,value=v,cnt=ln+rn+1,left=l,right=r}
  121.  
  122.     local
  123.       fun min (T{left=E,key,value,...}) = (key,value)
  124.         | min (T{left,...}) = min left
  125.         | min _ = raise Match
  126.   
  127.       fun delmin (T{left=E,right,...}) = right
  128.         | delmin (T{key,value,left,right,...}) = 
  129.       T'(key,value,delmin left,right)
  130.         | delmin _ = raise Match
  131.     in
  132.       fun delete' (E,r) = r
  133.         | delete' (l,E) = l
  134.         | delete' (l,r) = let val (mink,minv) = min r 
  135.               in T'(mink,minv,l,delmin r) end
  136.     end
  137. in
  138.     fun mkDict cmpKey = DICT(cmpKey, E)
  139.     
  140.     fun insert (DICT (cmpKey, t),x,v) = 
  141.     let fun ins E = T{key=x,value=v,cnt=1,left=E,right=E}
  142.           | ins (T(set as {key,left,right,value,...})) =
  143.         case cmpKey (key,x) of
  144.             GREATER => T'(key,value,ins left,right)
  145.           | LESS    => T'(key,value,left,ins right)
  146.           | _       => 
  147.             T{key=x,value=v,left=left,right=right,cnt= #cnt set}
  148.     in DICT(cmpKey, ins t) end
  149.  
  150.     fun find (DICT(cmpKey, t), x) =
  151.     let fun mem E = raise NotFound
  152.           | mem (T(n as {key,left,right,...})) =
  153.         case cmpKey (x,key) of
  154.             GREATER => mem right
  155.           | LESS    => mem left
  156.           | _       => #value n
  157.     in mem t end
  158.  
  159.     fun peek arg = (SOME(find arg)) handle NotFound => NONE
  160.  
  161.     fun remove (DICT(cmpKey, t), x) = 
  162.     let fun rm E = raise NotFound
  163.           | rm (set as T{key,left,right,value,...}) = 
  164.         (case cmpKey (key,x) of
  165.              GREATER => let val (left', v) = rm left
  166.                 in (T'(key, value, left', right), v) end
  167.            | LESS    => let val (right', v) = rm right
  168.                 in (T'(key, value, left, right'), v) end
  169.            | _       => (delete'(left,right),value))
  170.         val (newtree, valrm) = rm t
  171.     in (DICT(cmpKey, newtree), valrm) end
  172.  
  173.     fun listItems (DICT(_, d)) = 
  174.     let fun d2l E res = res
  175.           | d2l (T{key,value,left,right,...}) res =
  176.         d2l left ((key,value) :: d2l right res)
  177.     in d2l d [] end
  178.  
  179.     fun revapp f (DICT(_, d)) = let
  180.       fun a E = ()
  181.         | a (T{key,value,left,right,...}) = (a right; f(key,value); a left)
  182.       in a d end
  183.  
  184.     fun app f (DICT(_, d)) = let
  185.       fun a E = ()
  186.         | a (T{key,value,left,right,...}) = (a left; f(key,value); a right)
  187.       in a d end
  188.  
  189.     fun foldr f init (DICT(_, d)) = let
  190.       fun a E v = v
  191.         | a (T{key,value,left,right,...}) v = a left (f(key,value,a right v))
  192.       in a d init end
  193.  
  194.     fun foldl f init (DICT(_, d)) = let
  195.       fun a E v = v
  196.         | a (T{key,value,left,right,...}) v = a right (f(key,value,a left v))
  197.       in a d init end
  198.  
  199.     fun map f (DICT(cmpKey, d)) = let
  200.       fun a E = E
  201.         | a (T{key,value,left,right,cnt}) = let
  202.             val left' = a left
  203.             val value' = f(key,value)
  204.             in
  205.               T{cnt=cnt, key=key,value=value',left = left', right = a right}
  206.             end
  207.       in DICT(cmpKey, a d) end
  208.  
  209.     fun transform f (DICT(cmpKey, d)) = 
  210.     let fun a E = E
  211.           | a (T{key,value,left,right,cnt}) = 
  212.         let val left' = a left
  213.         in
  214.             T{cnt=cnt, key=key, value=f value, left = left', 
  215.               right = a right}
  216.         end
  217.       in DICT(cmpKey, a d) end
  218. end
  219.